home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Scrabble / scrabble.icl < prev    next >
Encoding:
Text File  |  1997-05-14  |  17.5 KB  |  460 lines  |  [TEXT/3PRM]
  1. module    scrabble
  2.  
  3.  
  4. /*    Original program written by Paul de Mast in the functional programming language Amanda.
  5.     This program is the translated and adapted version to Clean.
  6. */
  7.  
  8.  
  9. import    StdEnv
  10. import    deltaEventIO, deltaDialog, deltaTimer, deltaWindow, deltaMenu, deltaFileSelect, deltaIOState, scrollList
  11. import    board, graphics, state, language
  12. import    Help
  13.  
  14.  
  15. /***************************************************************************************************************
  16.     The Start rule creates the GUI of the scrabble game and the initial program state.
  17. ****************************************************************************************************************/
  18. Start :: *World -> *World
  19. Start world
  20. #    (es,world)                    = OpenEvents world
  21.     (fs,world)                    = openfiles  world
  22.     (aboutdialog,fs)            = MakeAboutDialog "Scrabble" helpfilename fs help
  23.     t0                            = initstate fs
  24.     (kind1,kind2,strength,t1)    = (\t=:{player1,player2,strength}->(player1.kind,player2.kind,strength,t)) t0
  25.     (tn,es)                        = StartIO [    MenuSystem
  26.                                                 [    scrabblemenu (kind1,kind2)
  27.                                                 ,    strengthmenu strength
  28.                                                 ]
  29.                                           ,    TimerSystem 
  30.                                                   [    Timer computerId Unable 0 computer
  31.                                                   ]
  32.                                           ,    DialogSystem
  33.                                                   [    aboutdialog
  34.                                                   ]
  35.                                           ] t1 [initialisestate,scrabblepanel,arbitrate] es
  36.     world                        = CloseEvents es world
  37.     world                        = closefiles tn.files world
  38. =    world
  39.  
  40.  
  41. /***************************************************************************************************************
  42.     The user request the placement of a word.
  43. ****************************************************************************************************************/
  44. placeword :: DialogInfo State (IOState State) -> (State,IOState State)
  45. placeword info t=:{    board
  46.                   ,    playmode
  47.                   ,    dimensions=(minx,maxx,miny,maxy)
  48.                   ,    player
  49.                   , player1
  50.                   ,    player2
  51.                   ,    letterbox
  52.                   ,    lexicon
  53.                   ,    random
  54.                   }    io
  55. |    lastword==""
  56. =    arbitrate nt (drawplayerletters player newplayerletters (drawcommunication text io))
  57.     with
  58.         nt                    = {t2 & random=rs1,letterbox=restletterbox}
  59.         t2
  60.         |    player==Player1    = {t1 & playmode= EndPlayer1
  61.                                   , player1 = {t1.player1 & letters=newplayerletters,placedword=False}}
  62.         |    otherwise        = {t1 & playmode= EndPlayer2
  63.                                   , player2 = {t1.player2 & letters=newplayerletters,placedword=False}}
  64.         
  65.         text                = [toString player+++exchanges_letters]
  66.         (restletterbox,newplayerletters,rs1)
  67.                             = grab (playerletters++letterbox) 7 random
  68.  
  69. |    not (seek lexicon lastword)
  70. =    OpenModalDialog (newwordspanel [lastword:unknownwords] info) t1 io
  71.  
  72. |    outsideboard
  73. =    (t1,drawcommunication text io)
  74.     with
  75.         text    = [    toString player+++":" : placement_error lastword (i+1,j+1) ]
  76.  
  77. |    not (isEmpty missingletters)
  78. =    (t1,drawcommunication text io)
  79.     with
  80.         text    = [    toString player+++":" : missing_letters_error missingletters ]
  81.  
  82. |    not possible
  83. =    (t1,drawcommunication [ toString player+++":" : anonymous_placement_error ] io)
  84.  
  85. |    not (isEmpty unknownwords)
  86. =    OpenModalDialog (newwordspanel unknownwords info) t1 io
  87.  
  88. |    otherwise
  89. =    arbitrate nt (    drawplayerinfo player totalscore newplayerletters    (
  90.                     drawcommunication text                                (
  91.                     redrawboard nb io)))
  92.     with
  93.         nt
  94.         |    player==Player1    = {nt1 & player1    = setplayer newplayerletters totalscore True nt1.player1
  95.                                    , playmode    = EndPlayer1}
  96.         |    otherwise        = {nt1 & player2    = setplayer newplayerletters totalscore True nt1.player2
  97.                                    , playmode    = EndPlayer2}
  98.         setplayer letters score placed player
  99.                             = {player & letters=letters,points=score,placedword=placed}
  100.         nt1                 = {t1  & letterbox    = restletterbox
  101.                                    , dimensions    = newdimensions
  102.                                    , board        = nb
  103.                                    , random        = rs1
  104.                               }
  105.         newplayerletters    = remainingletters++replenishletters
  106.         (restletterbox,replenishletters,rs1)
  107.                             = grab letterbox (7-length remainingletters) random
  108.         text                = nr_new_words_placed ((length newwords)+1) [lastword:newwords]
  109. where
  110.     (x,y)                = (\(PairCS (IntCS x) (IntCS y))->(x,y)) (GetControlState 100 info)
  111.     direction            = if (GetSelectedRadioItemId 1 info==201) Hor Ver
  112.     lastword            = GetEditText 200 info
  113.     t1                    = {t & direction=direction}
  114.     
  115.     (playerletters,playerscore)
  116.                         = playerinfo
  117.     playerinfo
  118.     |    player==Player1    = (player1.letters,player1.points)
  119.     |    otherwise        = (player2.letters,player2.points)
  120.     newdimensions
  121.     |    direction==Hor    = (min i minx, max (i+wordlength-1) maxx, min j miny, max j maxy)
  122.     |    otherwise        = (min i minx, max i maxx, min j miny, max (j+wordlength-1) maxy)
  123.     
  124.     outsideboard        = (direction==Hor && ((i+wordlength<minx)||(i>maxx+1)||(j<miny-1)||(j>maxy+1)))
  125.                             ||
  126.                           (direction==Ver && ((i<minx-1)||(i>maxx+1)||(j+wordlength<miny-1)||(j>maxy+1)))
  127.                             ||
  128.                           (isEmpty newwords && length usedletters==wordlength && not firstturn)
  129.     
  130.     unknownwords        = filter (not o (seek lexicon)) newwords
  131.     
  132.     wordlength            = size lastword
  133.     firstturn            = player1.points+player2.points==0
  134.     
  135.     totalscore            = if (length usedletters==7) (playerscore+score+50) (playerscore+score)
  136.     missingletters        = removeMembers usedletters playerletters
  137.     remainingletters    = removeMembers playerletters usedletters
  138.     (nb,possible,usedletters,score,newwords)
  139.                         = tryaddword board lastword (i,j) direction
  140.     (i,j)                = abs2rel (x,y)
  141.  
  142.  
  143. /***************************************************************************************************************
  144.     arbitrate determines who's to play.
  145. ****************************************************************************************************************/
  146. arbitrate :: State (IOState State) -> (State,IOState State)
  147. arbitrate t=:{playmode,player,player1,player2,letterbox} io
  148. |    isEmpty letterbox && not player1.placedword && not player2.placedword
  149. =    (t, drawcommunication [text] (DisableTimer computerId io))
  150.     with
  151.         text        = if (player1.points>player2.points) (toString Player1+++has_won)
  152.                     ( if (player2.points>player1.points) (toString Player2+++has_won)
  153.                                                          is_a_draw
  154.                     )
  155.  
  156. |    (player==Player1 && playmode==EndPlayer1 && player2.kind==Computer) ||
  157.     (player==Player2 && playmode==EndPlayer2 && player1.kind==Computer)
  158. =    (    nt
  159.     ,    EnableTimer  computerId                                (
  160.           ChangeDialog scrabbleId [DisableDialogItems [3]]    (
  161.           drawletterbox letterbox io1))
  162.     )
  163.     with
  164.         (boardletters,t1)    = getboardletters t
  165.         playerletters        = if (nextplayer==Player1) player1.letters player2.letters
  166.         initprogress        = Letter firstletter initplacing
  167.         sortedletters        = sort (filter ((<>) ' ') (removeDup (playerletters++boardletters)))
  168.         firstletter            = if (isEmpty sortedletters) '@' (hd sortedletters)
  169.         nt                    = {t1 &    progress    = initprogress
  170.                                   ,    player        = nextplayer
  171.                                   ,    playmode    = Playing
  172.                               }
  173.  
  174. |    playmode==EndPlayer1 || playmode==EndPlayer2
  175. =    (    {t & player=nextplayer,playmode=Playing}
  176.     ,    DisableTimer computerId                            (
  177.           ChangeDialog scrabbleId [EnableDialogItems [3]]    (
  178.           drawletterbox letterbox io1))
  179.     )
  180.  
  181. |    otherwise
  182. =    (t,io)
  183. where
  184.     nextplayer            = otherplayer player
  185.     io1                    = drawcommunication [toString nextplayer+++is_move] io
  186.  
  187.  
  188. /***************************************************************************************************************
  189.     The computer player (a timer) determines a move.
  190. ****************************************************************************************************************/
  191. computer :: TimerState State (IOState State) -> (State, IOState State)
  192. computer _ t=:{    board
  193.               ,    dimensions
  194.               ,    player
  195.               ,    player1
  196.               ,    player2
  197.               ,    strength
  198.               ,    playmode
  199.               ,    lexicon
  200.               ,    letterbox
  201.               ,    progress
  202.               ,    random
  203.               }    io
  204. |    notyetready progress
  205. =    (nt, drawprogress player progress newplacing io)
  206.     with
  207.         (newplacing,t2)    = getnewplacing t1
  208.         nt                = {t2 & progress=newprogress}
  209.  
  210.         getnewplacing :: State -> (Placing,State)
  211.         getnewplacing t=:{    board
  212.                          ,    dimensions
  213.                          ,    player
  214.                          ,    player1
  215.                          ,    player2
  216.                          ,    strength
  217.                          ,    lexicon
  218.                          ,    progress
  219.                          }
  220.         |    isMember (getletter progress) playerletters
  221.         =    (newmaximumplacings board lexicon playerletters dimensions progress strength firstturn,t)
  222.         |    otherwise
  223.         =    (newmaximumplacing board lexicon playerletters (horpos,verpos) progress strength firstturn,t)
  224.         where
  225.             playerletters
  226.             |    player==Player1    = player1.letters
  227.             |    otherwise        = player2.letters
  228.             horpos                = getfreehorpositions board (getletter progress)
  229.             verpos                = getfreeverpositions board (getletter progress)
  230.             firstturn            = player1.points+player2.points==0
  231.         
  232.         newprogress
  233.         |    lastletter<>'z' && newletter<>'@'
  234.                         = Letter newletter newplacing
  235.         |    otherwise    = Finish newplacing
  236.         where
  237.             lastletter    = getletter progress
  238.             nextletters    = dropWhile (\l->(l<=lastletter)) (sort (filter ((<>) ' ') (removeDup (playerletters++boardletters))))
  239.             newletter    = if (isEmpty nextletters) '@' (hd nextletters)
  240.  
  241. |    wordfound
  242. =    arbitrate ntready    (drawplayerinfo player totalscore newplayerletters                            (
  243.                          drawcommunication (nr_new_words_placed ((length newwords)+1) [w:newwords])    (
  244.                          redrawboard nb    io)))
  245.  
  246. |    otherwise
  247. =    arbitrate ntready    (drawplayerletters player newplayerletters (
  248.                          drawcommunication [toString Computer+++exchanges_letters] io))
  249.  
  250. where
  251.     ntready
  252.     |    player==Player1            = {nt1 & player1 = {nt1.player1 & letters=newplayerletters,points=totalscore,placedword=wordfound}
  253.                                        , playmode= EndPlayer1}
  254.     |    otherwise                = {nt1 & player2 = {nt1.player2 & letters=newplayerletters,points=totalscore,placedword=wordfound}
  255.                                        , playmode= EndPlayer2}
  256.     nt1                            = {t1  & board        = nb
  257.                                        , letterbox    = restletterbox
  258.                                        , dimensions    = newdimensions
  259.                                        , random        = rs1
  260.                                   }
  261.     (boardletters,t1)            = getboardletters t
  262.     placing                        = getplacing progress
  263.     w                            = placing.word
  264.     r                            = placing.dir
  265.     pos                            = placing.pos
  266.     (i,j)                        = pos
  267.     wordlength                    = size w
  268.     wordfound                    = wordlength>0
  269.     (minx,maxx,miny,maxy)        = dimensions
  270.     newdimensions
  271.     |    not wordfound            = dimensions
  272.     |    r==Hor                    = (min i minx, max (i+wordlength-1) maxx, min j miny, max j maxy)
  273.     |    otherwise                = (min i minx, max i maxx, min j miny, max (j+wordlength-1) maxy)
  274.     newplayerletters
  275.     |    not wordfound            = replenishletters
  276.     |    otherwise                = remainingletters++replenishletters
  277.     (restletterbox,replenishletters,rs1)
  278.                                 = grabletters
  279.     grabletters
  280.     |    not wordfound            = grab (playerletters++letterbox) 7 random
  281.     |    otherwise                = grab letterbox (7-length remainingletters) random
  282.     
  283.     (playerletters,playerscore)    = playerinfo
  284.     playerinfo
  285.     |    player==Player1            = (player1.letters,player1.points)
  286.     |    otherwise                = (player2.letters,player2.points)
  287.     totalscore                    = playerscore+score
  288.     remainingletters            = removeMembers playerletters usedletters
  289.     
  290.     (nb,_,usedletters,score,newwords)
  291.                                 = tryaddword board w pos r
  292.  
  293. //    Auxiliary functions:
  294. drawplayerletters :: Player [Char] (IOState t) -> IOState t
  295. drawplayerletters player letters io
  296. |    player==Player1    = drawplayer1letters letters io
  297. |    otherwise        = drawplayer2letters letters io
  298.  
  299. drawplayerinfo :: Player Int [Char] (IOState t) -> IOState t
  300. drawplayerinfo player score letters io
  301. |    player==Player1    = drawplayer1score score (drawplayer1letters letters io)
  302. |    otherwise        = drawplayer2score score (drawplayer2letters letters io)
  303.  
  304.  
  305. /***************************************************************************************************************
  306.     The help information should be displayed.
  307. ****************************************************************************************************************/
  308.  
  309. help :: State (IOState State) -> (State,IOState State)
  310. help t=:{files} io
  311. #    (files,io)    = ShowHelp helpfilename files io
  312. =    ({t & files=files},io)
  313.  
  314.  
  315. /***************************************************************************************************************
  316.     The definition of the scrabble GUI.
  317. ****************************************************************************************************************/
  318.  
  319. scrabblemenu (kind1,kind2)
  320. =    PullDownMenu 1 scrabblemenutitle Able 
  321.         [    SubMenuItem   1 playersmenutitle Able
  322.         [    MenuRadioItems initmarkid
  323.         [    MenuRadioItem cpid (computer+++"/"+++person)    NoKey        Able (setplayerkinds Computer Person  )
  324.         ,    MenuRadioItem ccid (computer+++"/"+++computer)    (Key 'C')    Able (setplayerkinds Computer Computer)
  325.         ,    MenuRadioItem ppid (person  +++"/"+++person)    (Key 'P')    Able (setplayerkinds Person   Person  )
  326.         ,    MenuRadioItem pcid (person  +++"/"+++computer)    NoKey        Able (setplayerkinds Person   Computer)
  327.         ]]
  328.         ,    MenuItem 310 newgametitle    (Key 'n') Able new
  329.         ,    MenuItem 2   quitgametitle    (Key 'q') Able quit
  330.         ]
  331. where
  332.     computer    = toString Computer
  333.     person        = toString Person
  334.     cpid        = 330;    ccid    = 331;    ppid    = 332;    pcid    = 333;
  335.     initmarkid
  336.     |    kind1==Person  && kind2==Computer    = pcid
  337.     |    kind1==Computer&& kind2==Computer    = ccid
  338.     |    kind1==Person  && kind2==Person        = ppid
  339.     |    otherwise                            = cpid
  340.     
  341.     setplayerkinds :: Playerkind Playerkind State (IOState State) -> (State,IOState State)
  342.     setplayerkinds s1 s2 t=:{player1,player2} io = new {t & player1={player1 & kind=s1},player2={player2 & kind=s2}} io
  343.  
  344. new :: State (IOState State) -> (State,IOState State)
  345. new t io
  346. #    io        = CloseDialog scrabbleId io
  347.     (t,io)    = initialisestate t io
  348.     (t,io)    = scrabblepanel t io
  349.     (t,io)    = arbitrate t io
  350. =    (t,io)
  351.  
  352. quit :: State (IOState State) -> (State,IOState State)
  353. quit t=:{wordsadded,lexicon} io
  354. |    not wordsadded
  355. =    (t,QuitIO io)
  356. #    (decision,t,io)    = OpenNotice save t io
  357. |    decision==no
  358. =    (t,QuitIO io)
  359. =    ({t & files=writetree lexicon t.files},QuitIO io)
  360. where
  361.     yes        = 1
  362.     no        = 2
  363.     save    = Notice save_notice_text
  364.                 (NoticeButton yes save_notice_yes)
  365.                 [NoticeButton no  save_notice_no]
  366.  
  367.  
  368. strengthmenu strength
  369. =    PullDownMenu 2 strengthmenutitle Able
  370.         [    MenuRadioItems initstrength
  371.         [    MenuRadioItem maxid            (toString Maximum)            NoKey Able (setstrength Maximum)
  372.         ,    MenuRadioItem mediumid        (toString MediumStrength)    NoKey Able (setstrength MediumStrength)
  373.         ,    MenuRadioItem easyid        (toString EasyStrength)        NoKey Able (setstrength EasyStrength)
  374.         ,    MenuRadioItem veryeasyid    (toString VeryEasyStrength)    NoKey Able (setstrength VeryEasyStrength)
  375.         ,    MenuRadioItem firstid        (toString First)            NoKey Able (setstrength First)
  376.         ]]
  377. where
  378.     maxid    = 320;    firstid    = 321;    mediumid    = 322;    easyid    = 323;    veryeasyid    = 324;
  379.     initstrength
  380.     |    strength==Maximum            = maxid
  381.     |    strength==First                = firstid
  382.     |    strength==MediumStrength    = mediumid
  383.     |    strength==EasyStrength        = easyid
  384.     |    otherwise                    = veryeasyid
  385.     
  386.     setstrength :: Strength State (IOState State) -> (State,IOState State)
  387.     setstrength nst t io = ({t & strength=nst},io)
  388.  
  389.  
  390. scrabblepanel :: State (IOState State) -> (State,IOState State)
  391. scrabblepanel t=:{lexicon,player1,player2,player,letterbox} io
  392. =    (t,OpenDialog panel io)
  393. where
  394.     panel = CommandDialog scrabbleId scrabbledialogtitle [DialogMargin (Pixel 10) (Pixel 10)] 3
  395.                 ([    Control         111 Left ((0,0),sizeletterbox) Unable (ListCS []) (letterboxlook letterbox) nofeel k`
  396.                 ,    Control         100 (RightTo 111) ((0,0),(boardwidth,boardheight)) (if personplaying Able Unable)
  397.                                      (cs_tuple (boardwidth/2) (boardheight/2)) 
  398.                                      (boardlook initboard (boardwidth,boardheight)) boardfeel k`
  399.                 ,    StaticText     101 (XOffset 100 (Pixel 10)) (toString Player1+++":")
  400.                 ,    Control         102 (YOffset 101 (Pixel 0)) ((0,0),sizeletters) Unable
  401.                                      (StringCS (toString player1.letters)) (playerletterslook sizeletters) nofeel k`
  402.                 ,    StaticText     105 (XOffset 101 (Pixel 140)) (scrabbledialogscore+++":")
  403.                 ,    DynamicText     106 (YOffset 105 (Pixel 0)) (Pixel 40) (toString 0)
  404.                 ,    StaticText     103 (YOffset 102 (Pixel 10)) (toString Player2+++":")
  405.                 ,    Control         104 (YOffset 103 (Pixel 0)) ((0,0),sizeletters) Unable
  406.                                      (StringCS (toString player2.letters)) (playerletterslook sizeletters) nofeel k`
  407.                 ,    StaticText     107 (XOffset 103 (Pixel 140)) (scrabbledialogscore+++":")
  408.                 ,    DynamicText     108 (YOffset 107 (Pixel 0)) (Pixel 40) (toString 0)
  409.                 ,    Control         110 (YOffset 104 (Pixel 20)) ((-2,-2),(displaywidth+2,displayheight+2)) Unable
  410.                                      (ListCS (map toStringCS (scrabbledialoginittext lexicon)))
  411.                                      (displaylook (displaywidth,displayheight)) nofeel k`
  412.                 ]
  413.                 ++
  414.                 (if    (not personplaying)
  415.                 []
  416.                 [    StaticText     109 (YOffset 110 (Pixel 20)) (scrabbledialogword+++":")
  417.                 ,    EditText     200 (XOffset 109 (Pixel 5)) (Pixel 80) 1 ""
  418.                 ,    StaticText     0     (Below 109)  scrabbledialogdirection
  419.                 ,    RadioButtons 1     (Below 200)  (Columns 1) 201
  420.                 [    RadioItem     201 (toString Hor) Able k`
  421.                 ,    RadioItem     202 (toString Ver) Able k`
  422.                 ]
  423.                 ,    DialogButton 3 (Below 1) scrabbledialogplaceword selectstateplaceword placeword
  424.                 ]))
  425.     nofeel _ cs                = (cs,[])
  426.     k` _ x                    = x
  427.     cs_tuple x y            = PairCS (IntCS x) (IntCS y)
  428.     sizeletterbox            = (squarewidth*4,squareheight*15)
  429.     sizeletters                = (squarewidth*7,squareheight)
  430.     personplaying            = player1.kind==Person || player2.kind==Person
  431.     selectstateplaceword
  432.     |    player==Player1 && player1.kind==Person
  433.                             = Able
  434.     |    player==Player2 && player2.kind==Person
  435.                             = Able
  436.     |    otherwise            = Unable
  437.     
  438.     boardfeel :: MouseState ControlState -> (ControlState,[DrawFunction])
  439.     boardfeel ((x,y),ButtonDown,_) oldcs
  440.     =    (newcs,drawfocus False oldcs ++ drawfocus True newcs)
  441.     where
  442.         newcs                = cs_tuple x y
  443.     boardfeel _ cs
  444.     =    (cs,[])
  445.  
  446. newwordspanel words info
  447. =    CommandDialog toevoegId addwordstitle [] 202
  448.         [    StaticText      0        Center mededeling1
  449.         ,    StaticText      1        Center mededeling2
  450.         ,    ScrollingList 300    Center (Pixel 260) Able (max 10 10) (hd words) words (\_ ds->ds)
  451.         ,    DialogButton  2        Center        addwords_no  Able (\_ s io->(s,CloseActiveDialog io))
  452.         ,    DialogButton  202    (RightTo 2)    addwords_yes Able (add words info)
  453.         ]
  454. where
  455.     (mededeling1,mededeling2)    = addwordsheading (length words)
  456.     
  457.     add :: [Word] DialogInfo DialogInfo State (IOState State) -> (State,IOState State)
  458.     add words info _ t=:{lexicon} io
  459.     =    placeword info {t & lexicon=addwordstotree lexicon words,wordsadded=True} (CloseActiveDialog io)
  460.